home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 005 / epistat.arc / FISHERS.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1983-08-18  |  1.8 KB  |  39 lines
  1. 1  REM              FISHER'S EXACT TEST (one-tailed)
  2. 2  REM             Written by Tracy L. Gustafson, M.D.
  3. 3  REM            Round Rock, Texas. Version 2.0, 1982
  4. 5  DEF SEG=&H40
  5. 6  A=PEEK(&H17): IF NOT(A AND &H20) THEN POKE &H17,(A AND (NOT &H20)) OR &H20
  6. 10  DEF SEG: CLEAR: WIDTH 80: SCREEN 0,0: COLOR 7,0,4: KEY OFF: DEFINT I,N
  7. 25  CLS: PRINT: PRINT TAB(27);"KEYTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENCLOSE"
  8. 30  PRINT TAB(27);"OPEN FISHER'S EXACT TEST OPEN"
  9. 35  PRINT TAB(27);"SCREENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENLOAD": PRINT: PRINT
  10. 40  P=0: PRINT " Enter four integers in 2 by 2 table:": PRINT
  11. 42  PRINT TAB(22);"VARPTRSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDBSAVESOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDCOLOR"
  12. 43  PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL": PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL"
  13. 44  PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL"
  14. 45  PRINT TAB(22);"BLOADSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDBEEPSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUND<0xB4!>"
  15. 46  PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL": PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL"
  16. 47  PRINT TAB(22);"CALL";TAB(38);"CALL";TAB(54);"CALL"
  17. 48  PRINT TAB(22);"CLSSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDMOTORSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUNDSOUND'"
  18. 50  LOCATE 11,25: INPUT;"A=  ",A: X=A: NL=50: GOSUB 250
  19. 55  LOCATE 11,42: INPUT "B=  ",B: X=B: GOSUB 250: PRINT
  20. 60  LOCATE 15,25: INPUT;"C=  ",C: X=C: GOSUB 250
  21. 65  LOCATE 15,42: INPUT "D=  ",D: X=D: GOSUB 250
  22. 85  LOCATE 19,27: COLOR 23: PRINT "CALCULATING PROBABILITY";
  23. 90  M=A: IF B<M THEN M=B: SWAP A,B: SWAP C,D
  24. 100  IF D<M THEN M=D: SWAP A,D: SWAP B,C: GOTO 90
  25. 110  IF C<M THEN M=C: SWAP A,C: SWAP B,D
  26. 115  IF A/B>C/D THEN IF C>B THEN SWAP A,B: SWAP C,D ELSE SWAP A,C: SWAP B,D
  27. 120  TP=0: N=1
  28. 130  FOR I=(B+1) TO (A+B): TP=TP*I/N: N=N+1: NEXT: N=B+D+1
  29. 140  FOR I=(C+1) TO (A+C): TP=TP*I/N: N=N+1: NEXT: TP=TP*1E+30
  30. 150  FOR I=(D+1) TO (C+D): TP=TP*I/N: N=N+1: NEXT: P=P+TP
  31. 170  IF A>0 AND TP>0 THEN A=A-1: B=B+1: C=C+1: D=D-1: GOTO 120
  32. 180  PLAY "MB L32 N20N24N27 L16 N32 L3 N20"
  33. 190  COLOR 0,7: LOCATE 19,15: PRINT TAB(30);"p = ";: IF P<9E-09 THEN PRINT "< 10 (-8)"; ELSE PRINT P;
  34. 220  PRINT TAB(63): COLOR 7,0: PRINT: PRINT: PRINT: PRINT TAB(8);
  35. 230  INPUT "Do you want to perform another Fisher's exact test? (Y or N)   ",A$
  36. 240  IF A$="y" OR A$="Y" THEN CLS: GOTO 25
  37. 245  END
  38. 250  IF INT(X)=X THEN RETURN ELSE BEEP: LOCATE 20,25: PRINT "PLEASE ENTER INTEGERS ONLY!": FOR Z=1 TO 2000: NEXT: GOTO 25
  39.